home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 014 / pibcat.arc / PIBCATS.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1987-01-19  |  50.3 KB  |  1,017 lines
  1. (*--------------------------------------------------------------------------*)
  2. (*               Trim --- Trim trailing blanks from a string                *)
  3. (*--------------------------------------------------------------------------*)
  4.  
  5. FUNCTION Trim( S : AnyStr ) : AnyStr;
  6.  
  7. (*--------------------------------------------------------------------------*)
  8. (*                                                                          *)
  9. (*     Function:   Trim                                                     *)
  10. (*                                                                          *)
  11. (*     Purpose:    Trims trailing blanks from a string                      *)
  12. (*                                                                          *)
  13. (*     Calling sequence:                                                    *)
  14. (*                                                                          *)
  15. (*         Trimmed_S := TRIM( S );                                          *)
  16. (*                                                                          *)
  17. (*            S          --- the string to be trimmed                       *)
  18. (*            Trimmed_S  --- the trimmed version of S                       *)
  19. (*                                                                          *)
  20. (*     Calls:  None                                                         *)
  21. (*                                                                          *)
  22. (*     Remarks:                                                             *)
  23. (*                                                                          *)
  24. (*        Note that the original string itself is left untrimmed.           *)
  25. (*                                                                          *)
  26. (*--------------------------------------------------------------------------*)
  27.  
  28. VAR
  29.    I:       INTEGER;
  30.  
  31. BEGIN (* Trim *)
  32.  
  33.    I       := ORD( S[0] );
  34.  
  35.    WHILE ( I > 0 ) AND ( S[I] = ' ' ) DO
  36.       I := I - 1;
  37.  
  38.    S[0] := CHR( I );
  39.    Trim := S;
  40.  
  41. END   (* Trim *);
  42.  
  43. (*--------------------------------------------------------------------------*)
  44. (*                     Dupl -- Duplicate a character n times                *)
  45. (*--------------------------------------------------------------------------*)
  46.  
  47. FUNCTION Dupl( Dup_char : Char; Dup_Count: INTEGER ) : AnyStr;
  48.  
  49. (*--------------------------------------------------------------------------*)
  50. (*                                                                          *)
  51. (*    Function: Dupl                                                        *)
  52. (*                                                                          *)
  53. (*    Purpose:  Duplicate a character n times                               *)
  54. (*                                                                          *)
  55. (*    Calling Sequence:                                                     *)
  56. (*                                                                          *)
  57. (*       Dup_String := Dupl( Dup_Char: Char; Dup_Count: INTEGER ): AnyStr;  *)
  58. (*                                                                          *)
  59. (*          Dup_Char   --- Character to be duplicated                       *)
  60. (*          Dup_Count  --- Number of times to duplicate character           *)
  61. (*          Dup_String --- Resultant duplicated string                      *)
  62. (*                                                                          *)
  63. (*          Note:  If Dup_Count <= 0, a null string is returned.            *)
  64. (*                                                                          *)
  65. (*    Calls:  None                                                          *)
  66. (*                                                                          *)
  67. (*                                                                          *)
  68. (*    Remarks:                                                              *)
  69. (*                                                                          *)
  70. (*       This routine could be programmed directly in Turbo as:             *)
  71. (*                                                                          *)
  72. (*          VAR                                                             *)
  73. (*             S    : AnyStr;                                               *)
  74. (*                                                                          *)
  75. (*          BEGIN                                                           *)
  76. (*                                                                          *)
  77. (*             FillChar( S[1], Dup_Count, Dup_Char );                       *)
  78. (*             S[0] := CHR( Dup_Count );                                    *)
  79. (*                                                                          *)
  80. (*             Dupl := S;                                                   *)
  81. (*                                                                          *)
  82. (*          END;                                                            *)
  83. (*                                                                          *)
  84. (*--------------------------------------------------------------------------*)
  85.  
  86. BEGIN (* Dupl *)
  87.  
  88.    INLINE(  $16/                   (* PUSH      SS         ; Push stack ptr        *)
  89.             $07/                   (* POP       ES         ; For result addressing *)
  90.             $8B/$4E/$04/           (* MOV       CX,[BP+4]  ; Pick up dup count     *)
  91.             $88/$4E/$08/           (* MOV       [BP+8],CL  ; Store result length   *)
  92.             $8B/$46/$06/           (* MOV       AX,[BP+6]  ; Get char to duplicate *)
  93.             $8D/$7E/$09/           (* LEA       DI,[BP+9]  ; Result address        *)
  94.             $FC/                   (* CLD                  ; Set direction flag    *)
  95.             $F3/$AA                (* REPLSTOSB            ; Perform duplication   *)
  96.          );
  97.  
  98. END   (* Dupl *);
  99.  
  100. (*----------------------------------------------------------------------*)
  101. (*               Min --- Find minimum of two integers                   *)
  102. (*----------------------------------------------------------------------*)
  103.  
  104. FUNCTION Min( A, B: INTEGER ) : INTEGER;
  105.  
  106. (*----------------------------------------------------------------------*)
  107. (*                                                                      *)
  108. (*   Function: Min                                                      *)
  109. (*                                                                      *)
  110. (*   Purpose:  Returns smaller of two numbers                           *)
  111. (*                                                                      *)
  112. (*   Calling sequence:                                                  *)
  113. (*                                                                      *)
  114. (*      Smaller := MIN( A , B ) : INTEGER;                              *)
  115. (*                                                                      *)
  116. (*         A       --- 1st input integer number                         *)
  117. (*         B       --- 2nd input integer number                         *)
  118. (*         Smaller --- smaller of A, B returned                         *)
  119. (*                                                                      *)
  120. (*                                                                      *)
  121. (*   Calls:  None                                                       *)
  122. (*                                                                      *)
  123. (*                                                                      *)
  124. (*----------------------------------------------------------------------*)
  125.  
  126. BEGIN (* Min *)
  127.  
  128.    IF A < B Then
  129.       Min := A
  130.    Else
  131.       Min := B;
  132.  
  133. END   (* Min *);
  134.  
  135. (*----------------------------------------------------------------------*)
  136. (*               Max --- Find maximum of two integers                   *)
  137. (*----------------------------------------------------------------------*)
  138.  
  139. FUNCTION Max( A, B: INTEGER ) : INTEGER;
  140.  
  141. (*----------------------------------------------------------------------*)
  142. (*                                                                      *)
  143. (*   Function:  Max                                                     *)
  144. (*                                                                      *)
  145. (*   Purpose:  Returns larger of two numbers                            *)
  146. (*                                                                      *)
  147. (*   Calling sequence:                                                  *)
  148. (*                                                                      *)
  149. (*      Larger := MAX( A , B ) : INTEGER;                               *)
  150. (*                                                                      *)
  151. (*         A       --- 1st input integer number                         *)
  152. (*         B       --- 2nd input integer number                         *)
  153. (*         Larger  --- Larger of A, B returned                          *)
  154. (*                                                                      *)
  155. (*                                                                      *)
  156. (*   Calls:  None                                                       *)
  157. (*                                                                      *)
  158. (*----------------------------------------------------------------------*)
  159.  
  160. BEGIN (* Max *)
  161.  
  162.    IF A > B Then
  163.       Max := A
  164.    Else
  165.       Max := B;
  166.  
  167. END   (* Max *);
  168.  
  169. (*--------------------------------------------------------------------------*)
  170. (*                 Substr -- Get substring of a string                      *)
  171. (*--------------------------------------------------------------------------*)
  172.  
  173. FUNCTION Substr( S : AnyStr; IS : INTEGER; NS: INTEGER ) : AnyStr;
  174.  
  175. (*--------------------------------------------------------------------------*)
  176. (*                                                                          *)
  177. (*    Function: Substr                                                      *)
  178. (*                                                                          *)
  179. (*    Purpose:  Takes substring of a string                                 *)
  180. (*                                                                          *)
  181. (*    Calling Sequence:                                                     *)
  182. (*                                                                          *)
  183. (*       Sub_String := Substr(  S: Anystr;                                  *)
  184. (*                             IS: INTEGER;                                 *)
  185. (*                             NS: INTEGER ): AnyStr;                       *)
  186. (*                                                                          *)
  187. (*          S   --- String to get substring from                            *)
  188. (*          IS  --- Starting character in S of substring to extract         *)
  189. (*          NS  --- Number of characters to extract                         *)
  190. (*                                                                          *)
  191. (*    Calls:  Copy                                                          *)
  192. (*                                                                          *)
  193. (*    Remarks:                                                              *)
  194. (*                                                                          *)
  195. (*       This routine handles null strings which COPY doesn't like.         *)
  196. (*                                                                          *)
  197. (*--------------------------------------------------------------------------*)
  198.  
  199. VAR
  200.    L : INTEGER;
  201.    L0: INTEGER;
  202.  
  203. BEGIN (* Substr *)
  204.                                    (* Keep all strings in proper range *)
  205.    L0 := ORD( S[0] );
  206.    L  := L0 - IS + 1;
  207.  
  208.    IF( L < NS ) THEN
  209.       NS := L;
  210.                                    (* Extract substring or return null string *)
  211.  
  212.    IF ( NS <= 0 ) OR ( IS < 1 ) OR ( IS > L0 ) THEN
  213.       Substr := ''
  214.    ELSE
  215.       Substr := COPY( S, IS, NS );
  216.  
  217. END   (* Substr *);
  218.  
  219. (*--------------------------------------------------------------------------*)
  220. (*               UpperCase --- Convert string to upper case                 *)
  221. (*--------------------------------------------------------------------------*)
  222.  
  223. FUNCTION UpperCase( S: AnyStr ): AnyStr;
  224.  
  225. (*--------------------------------------------------------------------------*)
  226. (*                                                                          *)
  227. (*    Function: UpperCase                                                   *)
  228. (*                                                                          *)
  229. (*    Purpose:  Convert string to upper case                                *)
  230. (*                                                                          *)
  231. (*    Calling Sequence:                                                     *)
  232. (*                                                                          *)
  233. (*       Upper_String := UpperCase( S : AnyStr ): AnyStr;                   *)
  234. (*                                                                          *)
  235. (*          S            --- String to be converted to upper case           *)
  236. (*          Upper_String --- Resultant uppercase string                     *)
  237. (*                                                                          *)
  238. (*    Calls:  UpCase                                                        *)
  239. (*                                                                          *)
  240. (*    Remarks:                                                              *)
  241. (*                                                                          *)
  242. (*       This routine could be coded directly in Turbo as:                  *)
  243. (*                                                                          *)
  244. (*          VAR                                                             *)
  245. (*              I    : INTEGER;                                             *)
  246. (*              L    : INTEGER;                                             *)
  247. (*              T    : AnyStr;                                              *)
  248. (*                                                                          *)
  249. (*          BEGIN                                                           *)
  250. (*                                                                          *)
  251. (*             L := ORD( S[0] );                                            *)
  252. (*                                                                          *)
  253. (*             FOR I := 1 TO L DO                                           *)
  254. (*                T[I] := UpCase( S[I] );                                   *)
  255. (*                                                                          *)
  256. (*             T[0]      := CHR( L );                                       *)
  257. (*             UpperCase := T;                                              *)
  258. (*                                                                          *)
  259. (*         END;                                                             *)
  260. (*                                                                          *)
  261. (*--------------------------------------------------------------------------*)
  262.  
  263. BEGIN (* UpperCase *)
  264.  
  265.    INLINE(  $1E/                   (*      PUSH      DS          ; Save DS           *)
  266.             $8A/$4E/$04/           (*      MOV       CL,[BP+4]   ; Get length of S   *)
  267.             $30/$ED/               (*      XOR       CH,CH       ; Clear CH          *)
  268.             $8D/$76/$05/           (*      LEA       SI,[BP+5]   ; First source char *)
  269.             $8D/$BE/$04/$01/       (*      LEA       DI,[BP+260] ; Result length     *)
  270.             $36/$88/$0D/           (*      MOV       SS[DI],CL   ; Store length      *)
  271.             $80/$F9/$00/           (*      CMP       CL,0        ; Check for null    *)
  272.             $76/$18/               (*      JLE       L3          ; Quit if null      *)
  273.             $47/                   (*      INC       DI          ; First char result *)
  274.             $8C/$D0/               (*      MOV       AX,SS       ; Save stack addr   *)
  275.             $8E/$D8/               (*      MOV       DS,AX       ; For source        *)
  276.             $8E/$C0/               (*      MOV       ES,AX       ; For result        *)
  277.             $FC/                   (*      CLD                   ; Forward direction *)
  278.             $8A/$04/               (* L1:  MOV       AL,[SI]     ; Next source char  *)
  279.             $3C/$61/               (*      CMP       AL,'a'      ; Compare with 'a'  *)
  280.             $72/$06/               (*      JL        L2          ; Below  -- skip    *)
  281.             $3C/$7A/               (*      CMP       AL,'z'      ; Compare with 'z'  *)
  282.             $77/$02/               (*      JH        L2          ; Above  -- skip    *)
  283.             $2C/$20/               (*      SUB       AL,32       ; Uppercase letter  *)
  284.             $AA/                   (* L2:  STOSB                 ; Store in result   *)
  285.             $46/                   (*      INC       SI          ; Next char         *)
  286.             $E2/$F0/               (*      LOOP      L1          ;                   *)
  287.             $1F                    (* L3:  POP       DS          ; Restore DS        *)
  288.          );
  289.  
  290. END   (* UpperCase *);
  291.  
  292. (*--------------------------------------------------------------------------*)
  293. (*        Adjust_Hour --- Convert 24 hour time to 12 hour am/pm             *)
  294. (*--------------------------------------------------------------------------*)
  295.  
  296. PROCEDURE Adjust_Hour( VAR Hour : INTEGER;
  297.                        VAR AmPm : STRING2 );
  298.  
  299. (*----------------------------------------------------------------------*)
  300. (*                                                                      *)
  301. (*    Procedure: Adjust_Hour                                            *)
  302. (*                                                                      *)
  303. (*    Purpose:   Converts 24 hour time to 12 hour am/pm time            *)
  304. (*                                                                      *)
  305. (*    Calling sequence:                                                 *)
  306. (*                                                                      *)
  307. (*       Adjust_Hour( VAR Hour : INTEGER; AmPm : String2 );             *)
  308. (*                                                                      *)
  309. (*          Hour --- Input = Hours in 24 hour form;                     *)
  310. (*                   Output = Hours in 12 hour form.                    *)
  311. (*          AmPm --- Output 'am' or 'pm' indicator                      *)
  312. (*                                                                      *)
  313. (*----------------------------------------------------------------------*)
  314.  
  315. BEGIN (* Adjust_Hour *)
  316.  
  317.    IF ( Hour < 12 ) THEN
  318.       BEGIN
  319.          AmPm := 'am';
  320.          IF ( Hour = 0 ) THEN
  321.             Hour := 12;
  322.       END
  323.    ELSE
  324.       BEGIN
  325.          AmPm := 'pm';
  326.          IF ( Hour <> 12 ) THEN
  327.             Hour := Hour - 12;
  328.       END;
  329.  
  330. END   (* Adjust_Hour *);
  331.  
  332. (*----------------------------------------------------------------------*)
  333. (*   Convert_String_To_AsciiZ -- Convert Turbo string to Ascii Z String *)
  334. (*----------------------------------------------------------------------*)
  335.  
  336. PROCEDURE Convert_String_To_AsciiZ( VAR S: AnyStr );
  337.  
  338. (*----------------------------------------------------------------------*)
  339. (*                                                                      *)
  340. (*     Procedure:  Convert_String_To_AsciiZ                             *)
  341. (*                                                                      *)
  342. (*     Purpose:    Convert Turbo string to ascii Z string               *)
  343. (*                                                                      *)
  344. (*     Calling Sequence:                                                *)
  345. (*                                                                      *)
  346. (*        Convert_String_To_AsciiZ( VAR S: AnyStr );                    *)
  347. (*                                                                      *)
  348. (*           S --- Turbo string to be turned into Ascii Z string        *)
  349. (*                                                                      *)
  350. (*     Calls:                                                           *)
  351. (*                                                                      *)
  352. (*        None                                                          *)
  353. (*                                                                      *)
  354. (*----------------------------------------------------------------------*)
  355.  
  356. BEGIN (* Convert_String_To_AsciiZ *)
  357.  
  358.    S := S + CHR( 0 );
  359.  
  360. END   (* Convert_String_To_AsciiZ *);
  361.  
  362. (*----------------------------------------------------------------------*)
  363. (*     Dir_Set_Disk_Transfer_Address --- Set DMA address for disk I/O   *)
  364. (*----------------------------------------------------------------------*)
  365.  
  366. PROCEDURE Dir_Set_Disk_Transfer_Address( VAR DMA_Buffer );
  367.  
  368. (*----------------------------------------------------------------------*)
  369. (*                                                                      *)
  370. (*     Procedure:  Dir_Set_Disk_Transfer_Address                        *)
  371. (*                                                                      *)
  372. (*     Purpose:    Sets DMA address for disk transfers                  *)
  373. (*                                                                      *)
  374. (*     Calling Sequence:                                                *)
  375. (*                                                                      *)
  376. (*        Dir_Set_Disk_Transfer_Address( VAR DMA_Buffer );              *)
  377. (*                                                                      *)
  378. (*           DMA_Buffer --- direct memory access buffer                 *)
  379. (*                                                                      *)
  380. (*     Calls:                                                           *)
  381. (*                                                                      *)
  382. (*        MsDos                                                         *)
  383. (*                                                                      *)
  384. (*----------------------------------------------------------------------*)
  385.  
  386. VAR
  387.    Dir_Reg: RegPack;
  388.  
  389. BEGIN (* Dir_Set_Disk_Transfer_Address *)
  390.  
  391.    Dir_Reg.Ax := $1A00;
  392.    Dir_Reg.Ds := SEG( DMA_Buffer );
  393.    Dir_Reg.Dx := OFS( DMA_Buffer );
  394.  
  395.    MsDos( Dir_Reg );
  396.  
  397. END   (* Dir_Set_Disk_Transfer_Address *);
  398.  
  399. (*----------------------------------------------------------------------*)
  400. (*            Dir_Get_Default_Drive --- Get Default Drive               *)
  401. (*----------------------------------------------------------------------*)
  402.  
  403. FUNCTION Dir_Get_Default_Drive: CHAR;
  404.  
  405. (*----------------------------------------------------------------------*)
  406. (*                                                                      *)
  407. (*     Function:  Dir_Get_Default_Drive                                 *)
  408. (*                                                                      *)
  409. (*     Purpose:   Gets default drive for disk I/O                       *)
  410. (*                                                                      *)
  411. (*     Calling Sequence:                                                *)
  412. (*                                                                      *)
  413. (*        Def_Drive := Dir_Get_Default_Drive : CHAR;                    *)
  414. (*                                                                      *)
  415. (*           Def_Drive --- Letter of default drive                      *)
  416. (*                                                                      *)
  417. (*     Calls:                                                           *)
  418. (*                                                                      *)
  419. (*        MsDos                                                         *)
  420. (*                                                                      *)
  421. (*----------------------------------------------------------------------*)
  422.  
  423. VAR
  424.    Dir_Reg: RegPack;
  425.  
  426. BEGIN  (* Dir_Get_Default_Drive *)
  427.  
  428.    Dir_Reg.Ah := $19;
  429.  
  430.    MsDos( Dir_Reg );
  431.  
  432.    Dir_Get_Default_Drive := CHR( Dir_Reg.Al + ORD( 'A' ) );
  433.  
  434. END   (* Dir_Get_Default_Drive *);
  435.  
  436. (*----------------------------------------------------------------------*)
  437. (*   Dir_Find_First_File --- Find First File Matching Given Specs       *)
  438. (*----------------------------------------------------------------------*)
  439.  
  440. FUNCTION Dir_Find_First_File(     File_Pattern: AnyStr;
  441.                               VAR First_File  : Directory_Record  ):
  442.                               INTEGER;
  443.  
  444. (*----------------------------------------------------------------------*)
  445. (*                                                                      *)
  446. (*     Function:   Dir_Find_First_File                                  *)
  447. (*                                                                      *)
  448. (*     Purpose:    Find first file in directory matching specs          *)
  449. (*                                                                      *)
  450. (*     Calling Sequence:                                                *)
  451. (*                                                                      *)
  452. (*        Iok := Dir_Find_First_File(     File_Pattern: AnyStr;         *)
  453. (*                                    VAR First_File  :                 *)
  454. (*                                        Directory_Record ): INTEGER;  *)
  455. (*                                                                      *)
  456. (*           File_Pattern --- File pattern to look for.                 *)
  457. (*           First_File   --- First file matching specs.                *)
  458. (*           Iok          --- 0 if file found, else MsDos return code.  *)
  459. (*                                                                      *)
  460. (*     Calls:                                                           *)
  461. (*                                                                      *)
  462. (*        Dir_Set_Disk_Transfer_Address                                 *)
  463. (*        MsDos                                                         *)
  464. (*                                                                      *)
  465. (*     Remarks:                                                         *)
  466. (*                                                                      *)
  467. (*        The file pattern can be any standard MSDOS file pattern,      *)
  468. (*        including wildcards.  For a complete directory list, enter    *)
  469. (*        '*.*' as the pattern.   Use routine 'Dir_Find_Next_File'      *)
  470. (*        to get the remaining files.                                   *)
  471. (*                                                                      *)
  472. (*----------------------------------------------------------------------*)
  473.  
  474. VAR
  475.    Dir_Reg: RegPack;
  476.  
  477. BEGIN (* Find_First_File *)
  478.  
  479.    Dir_Set_Disk_Transfer_Address( First_File );
  480.  
  481.    Convert_String_To_AsciiZ( File_Pattern );
  482.  
  483.    Dir_Reg.Ds := SEG( File_Pattern[1] );
  484.    Dir_Reg.Dx := OFS( File_Pattern[1] );
  485.    Dir_Reg.Ax := $4E00;
  486.    Dir_Reg.Cx := $FF;
  487.  
  488.    MsDos( Dir_Reg );
  489.  
  490.    IF ( Carry_Flag AND Dir_Reg.Flags ) = 0 THEN
  491.       Dir_Find_First_File := 0
  492.    ELSE
  493.       Dir_Find_First_File := Dir_Reg.Ax;
  494.  
  495. END   (* Find_First_File *);
  496.  
  497. (*----------------------------------------------------------------------*)
  498. (*     Dir_Find_Next_File  --- Find Next File Matching Given Specs      *)
  499. (*----------------------------------------------------------------------*)
  500.  
  501. FUNCTION Dir_Find_Next_File ( VAR Next_File : Directory_Record ) : INTEGER;
  502.  
  503. (*----------------------------------------------------------------------*)
  504. (*                                                                      *)
  505. (*     Function:   Dir_Find_Next_File                                   *)
  506. (*                                                                      *)
  507. (*     Purpose:    Finds next file in directory matching specs          *)
  508. (*                                                                      *)
  509. (*     Calling Sequence:                                                *)
  510. (*                                                                      *)
  511. (*        Iok := Dir_Find_Next_File ( VAR Next_File :                   *)
  512. (*                                        Directory_Record ) : INTEGER; *)
  513. (*                                                                      *)
  514. (*           Next_File    --- Next file matching specs.                 *)
  515. (*           Iok          --- Returned as 0 if file found, else MsDos   *)
  516. (*                            return code indicating error.             *)
  517. (*                                                                      *)
  518. (*     Calls:                                                           *)
  519. (*                                                                      *)
  520. (*        MsDos                                                         *)
  521. (*        Dir_Set_Disk_Transfer_Address                                 *)
  522. (*                                                                      *)
  523. (*----------------------------------------------------------------------*)
  524.  
  525. VAR
  526.    Dir_Reg : RegPack;
  527.  
  528. BEGIN (* Find_Next_File  *)
  529.  
  530.    Dir_Set_Disk_Transfer_Address( Next_File );
  531.  
  532.    Dir_Reg.Ax := $4F00;
  533.  
  534.    MsDos( Dir_Reg );
  535.  
  536.    IF ( Carry_Flag AND Dir_Reg.Flags ) = 0 THEN
  537.       Dir_Find_Next_File := 0
  538.    ELSE
  539.       Dir_Find_Next_File := Dir_Reg.Ax;
  540.  
  541. END   (* Find_Next_File  *);
  542.  
  543. (*----------------------------------------------------------------------*)
  544. (*     Dir_Get_Free_Space  --- Get free space in bytes on disk          *)
  545. (*----------------------------------------------------------------------*)
  546.  
  547. FUNCTION Dir_Get_Free_Space ( Drive : CHAR ) : REAL;
  548.  
  549. (*----------------------------------------------------------------------*)
  550. (*                                                                      *)
  551. (*     Function:   Dir_Get_Free_Space                                   *)
  552. (*                                                                      *)
  553. (*     Purpose:    Gets amount of available space on a drive            *)
  554. (*                                                                      *)
  555. (*     Calling Sequence:                                                *)
  556. (*                                                                      *)
  557. (*        FSpace := Dir_Get_Free_Space ( Drive : CHAR ) : REAL;         *)
  558. (*                                                                      *)
  559. (*           Drive        --- Drive letter for which to get free space  *)
  560. (*           Fspace       --- Returned number of bytes of free space    *)
  561. (*                                                                      *)
  562. (*     Calls:                                                           *)
  563. (*                                                                      *)
  564. (*        MsDos                                                         *)
  565. (*                                                                      *)
  566. (*     Remarks:                                                         *)
  567. (*                                                                      *)
  568. (*         If the free space can't be found, -1 is returned.            *)
  569. (*         This is most likely to happen if an unformatted or wrongly   *)
  570. (*         formatted disk is to be checked.                             *)
  571. (*                                                                      *)
  572. (*----------------------------------------------------------------------*)
  573.  
  574. VAR
  575.    Dir_Reg  : RegPack;
  576.    Clusters : REAL;
  577.    Sectors  : REAL;
  578.    Bytes    : REAL;
  579.  
  580. BEGIN (* Dir_Get_Free_Space  *)
  581.  
  582.                                    (* Request drive information *)
  583.  
  584.    Dir_Reg.DL := ORD(UpCase( Drive )) - ORD('A') + 1;
  585.    Dir_Reg.AH := $36;
  586.  
  587.    MsDos( Dir_Reg );
  588.  
  589.                                    (* Compute free space *)
  590.  
  591.    WITH Dir_Reg DO
  592.       BEGIN
  593.  
  594.          Sectors  := AX;
  595.          Clusters := BX;
  596.          Bytes    := CX;
  597.  
  598.          IF AX = $FFFF THEN
  599.             Dir_Get_Free_Space := -1.0
  600.          ELSE
  601.             Dir_Get_Free_Space := Clusters * Bytes * Sectors;
  602.  
  603.       END;
  604.  
  605. END   (* Dir_Get_Free_Space  *);
  606.  
  607. (*----------------------------------------------------------------------*)
  608. (*            Dir_Convert_Date --- Convert directory creation date      *)
  609. (*----------------------------------------------------------------------*)
  610.  
  611. PROCEDURE Dir_Convert_Date ( Date : INTEGER; VAR S_Date : AnyStr );
  612.  
  613. (*----------------------------------------------------------------------*)
  614. (*                                                                      *)
  615. (*     Procedure: Dir_Convert_Date                                      *)
  616. (*                                                                      *)
  617. (*     Purpose:   Convert creation date from directory to characters.   *)
  618. (*                                                                      *)
  619. (*     Calling Sequence:                                                *)
  620. (*                                                                      *)
  621. (*        Dir_Convert_Date( Date       : INTEGER;                       *)
  622. (*                          VAR S_Date : AnyStr ) : INTEGER;            *)
  623. (*                                                                      *)
  624. (*           Date   --- date as read from directory                     *)
  625. (*           S_Date --- converted date in yy/mm/dd                      *)
  626. (*                                                                      *)
  627. (*     Calls:                                                           *)
  628. (*                                                                      *)
  629. (*        STR                                                           *)
  630. (*                                                                      *)
  631. (*----------------------------------------------------------------------*)
  632.  
  633. VAR
  634.    YY : String[2];
  635.    MM : String[3];
  636.    DD : String[2];
  637.  
  638. BEGIN (* Dir_Convert_Date *)
  639.  
  640.    STR( ( 80 + ( Date SHR 9 ) ) : 2 , YY );
  641.  
  642.    MM := Month_Names[ ( Date AND $01E0 ) SHR 5 ];
  643.  
  644.    STR( ( Date AND $001F ):2 , DD );
  645.  
  646.    S_Date := DD + '-' + MM + '-' + YY;
  647.  
  648. END  (* Dir_Convert_Date *);
  649.  
  650. (*----------------------------------------------------------------------*)
  651. (*            Dir_Convert_Time --- Convert directory creation time      *)
  652. (*----------------------------------------------------------------------*)
  653.  
  654. PROCEDURE Dir_Convert_Time ( Time : INTEGER; VAR S_Time : AnyStr );
  655.  
  656. (*----------------------------------------------------------------------*)
  657. (*                                                                      *)
  658. (*     Procedure: Dir_Convert_Time                                      *)
  659. (*                                                                      *)
  660. (*     Purpose:   Convert creation time from directory to characters.   *)
  661. (*                                                                      *)
  662. (*     Calling Sequence:                                                *)
  663. (*                                                                      *)
  664. (*        Dir_Convert_Time( Time       : INTEGER;                       *)
  665. (*                          VAR S_Time : AnyStr ) : INTEGER;            *)
  666. (*                                                                      *)
  667. (*           Time   --- time as read from directory                     *)
  668. (*           S_Time --- converted time in hh:mm:ss                      *)
  669. (*                                                                      *)
  670. (*     Calls:                                                           *)
  671. (*                                                                      *)
  672. (*        STR                                                           *)
  673. (*                                                                      *)
  674. (*----------------------------------------------------------------------*)
  675.  
  676. VAR
  677.    HH   : String[2];
  678.    MM   : String[2];
  679.    AmPm : String[2];
  680.    Hour : INTEGER;
  681.  
  682. BEGIN (* Dir_Convert_Time *)
  683.  
  684.    Hour := ( Time SHR 11 );
  685.  
  686.    Adjust_Hour( Hour , AmPm );
  687.  
  688.    STR( Hour:2 , HH );
  689.  
  690.    STR( ( ( Time AND $07E0 ) SHR 5 ):2 , MM );
  691.    IF MM[1] = ' ' THEN MM[1] := '0';
  692.  
  693.    S_Time := HH + ':' + MM + ' ' + AmPm;
  694.  
  695. END  (* Dir_Convert_Time *);
  696.  
  697. (*----------------------------------------------------------------------*)
  698. (*     Dir_Get_Volume_Label   ---  Get volume label of a disk           *)
  699. (*----------------------------------------------------------------------*)
  700.  
  701. PROCEDURE Dir_Get_Volume_Label(     Volume       : CHAR;
  702.                                 VAR Volume_Label : AnyStr;
  703.                                 VAR Date         : INTEGER;
  704.                                 VAR Time         : INTEGER );
  705.  
  706. (*----------------------------------------------------------------------*)
  707. (*                                                                      *)
  708. (*    Procedure: Dir_Get_Volume_Label                                   *)
  709. (*                                                                      *)
  710. (*    Purpose:   Gets volume label for specified disk                   *)
  711. (*                                                                      *)
  712. (*    Calling sequence:                                                 *)
  713. (*                                                                      *)
  714. (*       Dir_Get_Volume_Label(     Volume       : CHAR;                 *)
  715. (*                             VAR Volume_Label : AnyStr;               *)
  716. (*                             VAR Date         : INTEGER;              *)
  717. (*                             VAR Time         : INTEGER );            *)
  718. (*                                                                      *)
  719. (*          Volume       --- Disk letter for which to get label         *)
  720. (*          Volume_Label --- Actual label itself                        *)
  721. (*          Date         --- Creation date of volume label              *)
  722. (*          Time         --- Creation time of volume label              *)
  723. (*                                                                      *)
  724. (*----------------------------------------------------------------------*)
  725.  
  726. VAR
  727.    Volume_Data : Directory_Record;
  728.    Regs        : RegPack;
  729.    Volume_Pat  : STRING[15];
  730.  
  731. BEGIN (* Dir_Get_Volume_Label *)
  732.  
  733.    WITH Regs DO
  734.       BEGIN
  735.                                    (* Set up DMA address for volume info *)
  736.  
  737.          Dir_Set_Disk_Transfer_Address( Volume_Data );
  738.  
  739.                                    (* Search root directory for label *)
  740.  
  741.          Volume_Pat := Volume + ':*.*';
  742.  
  743.          Convert_String_To_AsciiZ( Volume_Pat );
  744.  
  745.          Regs.Ds := SEG( Volume_Pat[1] );
  746.          Regs.Dx := OFS( Volume_Pat[1] );
  747.          Regs.Ax := $4E00;
  748.          Regs.Cx := Attribute_Volume_Label;
  749.  
  750.                                    (* Find volume label *)
  751.          MsDos( Regs );
  752.  
  753.          IF ( Carry_Flag AND Regs.Flags ) <> 0 THEN
  754.             BEGIN                  (* No volume label found *)
  755.                Volume_Label := '';
  756.                Date         := 0;
  757.                Time         := 0;
  758.             END
  759.          ELSE
  760.             WITH Volume_Data DO
  761.                BEGIN               (* Extract volume label *)
  762.                   Volume_Label := TRIM( COPY( File_Name, 1, POS( #0 , File_Name ) - 1 ) );
  763.                   Date         := File_Date;
  764.                   Time         := File_Time;
  765.                END;
  766.  
  767.      END (* WITH *);
  768.  
  769. END   (* Dir_Get_Volume_Label *);
  770.  
  771.  
  772. (*--------------------------------------------------------------------------*)
  773. (*     TimeOfDayString --- Return current time of day as string             *)
  774. (*--------------------------------------------------------------------------*)
  775.  
  776. FUNCTION TimeOfDayString : AnyStr;
  777.  
  778. (*--------------------------------------------------------------------------*)
  779. (*                                                                          *)
  780. (*     Function:  TimeOfDayString                                           *)
  781. (*                                                                          *)
  782. (*     Purpose:   Return current time of day as string                      *)
  783. (*                                                                          *)
  784. (*     Calling sequence:                                                    *)
  785. (*                                                                          *)
  786. (*        Tstring := TimeOfDayString : AnyStr;                              *)
  787. (*                                                                          *)
  788. (*           Tstring  --- Resultant 'HH:MM xx' form of time                 *)
  789. (*                                                                          *)
  790. (*--------------------------------------------------------------------------*)
  791.  
  792. VAR
  793.    Hours : INTEGER;
  794.    SH    : STRING[2];
  795.    SM    : STRING[2];
  796.    AmPm  : STRING[2];
  797.    Regs  : RegPack;
  798.  
  799. BEGIN (* TimeOfDayString *)
  800.                                    (* Time of day interrupt *)
  801.    Regs.Ax := $2C00;
  802.    INTR( $21 , Regs );
  803.  
  804.    Hours   := Regs.Ch;
  805.  
  806.    Adjust_Hour( Hours , AmPm );
  807.  
  808.    STR( Hours  :2, SH );
  809.    STR( Regs.Cl:2, SM );
  810.  
  811.    IF SM[1] = ' ' THEN SM[1] := '0';
  812.  
  813.    TimeOfDayString := SH + ':' + SM + ' ' + AmPm;
  814.  
  815. END   (* TimeOfDayString *);
  816.  
  817. (*--------------------------------------------------------------------------*)
  818. (*             DateString  --- Return current date in string form           *)
  819. (*--------------------------------------------------------------------------*)
  820.  
  821. FUNCTION DateString : AnyStr;
  822.  
  823. (*--------------------------------------------------------------------------*)
  824. (*                                                                          *)
  825. (*     Function:  DateString                                                *)
  826. (*                                                                          *)
  827. (*     Purpose:   Returns current date in string form                       *)
  828. (*                                                                          *)
  829. (*     Calling sequence:                                                    *)
  830. (*                                                                          *)
  831. (*        Dstring := DateString: AnyStr;                                    *)
  832. (*                                                                          *)
  833. (*           Dstring     --- Resultant string form of date                  *)
  834. (*                                                                          *)
  835. (*     Calls:  MsDos                                                        *)
  836. (*                                                                          *)
  837. (*--------------------------------------------------------------------------*)
  838.  
  839. VAR
  840.   RecPack:       RegPack;
  841.   Month:         STRING[3];
  842.   Day:           STRING[2];
  843.   Year:          STRING[2];
  844.  
  845. BEGIN (* DateString *)
  846.                                    (* Date function *)
  847.   RecPack.Ax := $2A00;
  848.                                    (* Get date from DOS *)
  849.   MsDos( RecPack );
  850.                                    (* Convert to MM/DD/YY string *)
  851.   WITH Recpack DO
  852.      BEGIN
  853.         STR( Cx - 1900 :2 , Year  );
  854.         STR( Dx MOD 256:2 , Day   );
  855.         Month := Month_Names[ Dx SHR 8 ];
  856.      END;
  857.  
  858.   DateString := Day + '-' + Month + '-' + Year;
  859.  
  860. END   (* DateString *);
  861.  
  862. (*----------------------------------------------------------------------*)
  863. (*         Long_To_Real --- Convert 32 bit INTEGER to real              *)
  864. (*----------------------------------------------------------------------*)
  865.  
  866. FUNCTION Long_To_Real( Long : LongInt ) : REAL;
  867.  
  868. VAR
  869.    RLow : REAL;
  870.    RHigh: REAL;
  871.  
  872. BEGIN (* Long_To_Real *)
  873.  
  874.    WITH Long DO
  875.      BEGIN
  876.                                    (* Convert low-order 16 bits *)
  877.         IF ( Low < 0 ) THEN
  878.            RLow := 65536.0 + Low
  879.         ELSE
  880.            RLow := Low;
  881.                                    (* Convert high-order 16 bits *)
  882.         IF ( High < 0 ) THEN
  883.            RHigh := 65536.0 + High
  884.         ELSE
  885.            RHigh := High;
  886.  
  887.      END;
  888.                                    (* Put 'em together! *)
  889.  
  890.    Long_To_Real := RHigh * 65536.0 + RLow;
  891.  
  892. END   (* Long_To_Real *);
  893.  
  894. (*----------------------------------------------------------------------*)
  895. (*            Open_File --- Open untyped file for processing            *)
  896. (*----------------------------------------------------------------------*)
  897.  
  898. PROCEDURE Open_File(     FileName : AnyStr;
  899.                      VAR AFile    : FILE;
  900.                      VAR File_Pos : REAL;
  901.                      VAR Error    : INTEGER );
  902.  
  903. (*----------------------------------------------------------------------*)
  904. (*                                                                      *)
  905. (*    Procedure: Open_File                                              *)
  906. (*                                                                      *)
  907. (*    Purpose:   Opens untyped file (of byte) for input                 *)
  908. (*                                                                      *)
  909. (*    Calling sequence:                                                 *)
  910. (*                                                                      *)
  911. (*       Open_File(     FileName : AnyStr;                              *)
  912. (*                  VAR AFile    : FILE;                                *)
  913. (*                  VAR File_Pos : REAL;                                *)
  914. (*                  VAR Error    : INTEGER );                           *)
  915. (*                                                                      *)
  916. (*          FileName --- Name of file to open                           *)
  917. (*          AFile    --- Associated file variable                       *)
  918. (*          File_Pos --- Initial byte offset in file (always set to 0)  *)
  919. (*          Error    --- =  0:  Open went OK.                           *)
  920. (*                       <> 0:  Open failed.                            *)
  921. (*                                                                      *)
  922. (*----------------------------------------------------------------------*)
  923.  
  924. BEGIN (* Open_File *)
  925.                                    (* Try opening file.  Access       *)
  926.                                    (* is essentially as file of byte. *)
  927.      (*$I-*)
  928.   ASSIGN( AFile , FileName );
  929.   RESET ( AFile , 1 );
  930.      (*$I+*)
  931.                                    (* Check if open went OK or not *)
  932.   IF ( IOResult <> 0 ) THEN
  933.      Error := Open_Error
  934.   ELSE
  935.      Error := 0;
  936.                                    (* We are at beginning of file *)
  937.   File_Pos := 0.0;
  938.  
  939. END   (* Open_File *);
  940.  
  941. (*----------------------------------------------------------------------*)
  942. (*              Close_File --- Close an unytped file                    *)
  943. (*----------------------------------------------------------------------*)
  944.  
  945. PROCEDURE Close_File( VAR AFile : FILE );
  946.  
  947. (*----------------------------------------------------------------------*)
  948. (*                                                                      *)
  949. (*    Procedure: Close_File                                             *)
  950. (*                                                                      *)
  951. (*    Purpose:   Closes untyped file                                    *)
  952. (*                                                                      *)
  953. (*    Calling sequence:                                                 *)
  954. (*                                                                      *)
  955. (*       Close_File( VAR AFile : FILE );                                *)
  956. (*                                                                      *)
  957. (*          AFile    --- Associated file variable                       *)
  958. (*                                                                      *)
  959. (*----------------------------------------------------------------------*)
  960.  
  961. BEGIN (* Close_File *)
  962.                                    (* Close the file *)
  963.       (*$I-*)
  964.    CLOSE( AFile );
  965.       (*$I+*)
  966.                                    (* Clear error flag *)
  967.    IF ( IOResult <> 0 ) THEN;
  968.  
  969. END   (* Close_File *);
  970.  
  971. (*----------------------------------------------------------------------*)
  972. (*          Quit_Found --- Check if ^C hit on keyboard                  *)
  973. (*----------------------------------------------------------------------*)
  974.  
  975. FUNCTION QuitFound : BOOLEAN;
  976.  
  977. (*----------------------------------------------------------------------*)
  978. (*                                                                      *)
  979. (*    Function:  Quit_Found                                             *)
  980. (*                                                                      *)
  981. (*    Purpose:   Determines if keyboard input is ^C                     *)
  982. (*                                                                      *)
  983. (*    Calling sequence:                                                 *)
  984. (*                                                                      *)
  985. (*       Quit := Quit_Found : BOOLEAN;                                  *)
  986. (*                                                                      *)
  987. (*          Quit  --- TRUE if ^C typed at keyboard.                     *)
  988. (*                                                                      *)
  989. (*    Remarks:                                                          *)
  990. (*                                                                      *)
  991. (*       The cataloguing process can be halted by hitting ^C at the     *)
  992. (*       keyboard.  This routine is called when Find_Files notices that *)
  993. (*       keyboard input is waiting.  If ^C is found, then cataloguing   *)
  994. (*       stops at the next convenient breakpoint.  The global variable  *)
  995. (*       User_Break indicates that a ^C was found.                      *)
  996. (*                                                                      *)
  997. (*----------------------------------------------------------------------*)
  998.  
  999. VAR
  1000.    Ch : CHAR;
  1001.  
  1002. BEGIN (* QuitFound *)
  1003.                                    (* Character was hit -- read it *)
  1004.    READ( Kbd, Ch );
  1005.                                    (* If it is a ^C, set User_Break *)
  1006.                                    (* so we halt at next convenient *)
  1007.                                    (* location.                     *)
  1008.  
  1009.    User_Break := User_Break OR ( Ch = ^C );
  1010.    QuitFound  := User_Break;
  1011.                                    (* Purge anything else in keyboard *)
  1012.                                    (* buffer                          *)
  1013.    WHILE( KeyPressed ) DO
  1014.       READ( Kbd, Ch );
  1015.  
  1016. END   (* QuitFound *);
  1017.